home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / compare-windows.lisp / compare-windows.lisp
Encoding:
Text File  |  1992-03-14  |  5.5 KB  |  147 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; compare-windows.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Implements a simple but very handy incremental compare feature. Works on
  10. the top two Fred windows.
  11.  
  12. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  13. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  14.  
  15.  
  16. ================================================================
  17. Status =========================================================
  18. ================================================================
  19. Implemented.
  20.  
  21.  
  22. ================================================================
  23. Change history =================================================
  24.  (ds = Dan Suthers/UMASS, mc = Matthew Cornell, kp Karsten Poeck)
  25. ================================================================
  26. ??        mc    Created.
  27. 15-Jan-90 ds    Put it in Edit menu with different name.
  28. 30-Jan-90 ds    Changed window-draw-contents to view-draw-contents for version
  29.          1.3.1.
  30. 20-Apr-90 mc    Added command-key binding for the menu item.
  31. 24-Apr-90 mc    Fixed getting the windows to scroll to show the insertion
  32.          bar once it's moved.
  33.         Distributed to public domain.
  34. 30-Jan-90 ds    Added PROVIDE :COMPARE-WINDOWS.
  35.  4-July-91 kp    Ported to MACL 2.0b1
  36.  2-Mar-92 mc    Fixed to work with mcl2.0f2 .
  37.  
  38. |#
  39.  
  40.  
  41. (in-package "COMMON-LISP-USER")
  42.  
  43.  
  44. (defun compare-windows
  45.        (&key (w1 (first (select-item-from-list (windows :class 'fred-window)
  46.                                                :window-title "Select compare window 1")))
  47.              (w2 (first (select-item-from-list (windows :class 'fred-window)
  48.                                                :window-title "Select compare window 2")))
  49.              (skip-white? t))
  50.   "Moves each window's cursor mark along if they point to the same character,
  51. skipping whitespace. Stops at the point where they are off, allowing the user
  52. to
  53. resynchronize and start again manually. Beeps if it fails (right?)."
  54.   ;;
  55.   (labels ((REMOVE-WHITESPACE (buffer mark size)
  56.              "Moves <mark> along until it doesn't point to whitespace (tab,
  57. space, or non-breaking white/decimal 202)."
  58.              (do ()
  59.                  ((or (= (buffer-position mark) size)    ;avoids a nasty error
  60.                       (not (ccl:whitespacep (buffer-char buffer mark)))))
  61.                (move-mark mark)))
  62.            (NOT-EQUAL-HERE? (w1-buf w1-mark w2-buf w2-mark)
  63.              "Returns t if w1 and w2 don't point to the same character."
  64.              (char-not-equal (buffer-char w1-buf w1-mark)
  65.                              (buffer-char w2-buf w2-mark))))
  66.     (let* ((w1-buf (fred-buffer w1))
  67.            (w1-mark w1-buf)
  68.            (w1-size (buffer-size w1-buf))
  69.            (w2-buf (fred-buffer w2))
  70.            (w2-mark w2-buf)
  71.            (w2-size (buffer-size w2-buf)))
  72.       (loop (when skip-white?
  73.               (REMOVE-WHITESPACE w1-buf w1-mark w1-size)
  74.               (REMOVE-WHITESPACE w2-buf w2-mark w2-size))
  75.             ;;
  76.             (cond ((or (= (buffer-position w1-mark) w1-size)
  77.                        (= (buffer-position w2-mark) w2-size))
  78.                    ;; someone reached the end so test if sucessful
  79.                    (cond ((and (= (buffer-position w1-mark) w1-size)
  80.                                (= (buffer-position w2-mark) w2-size))
  81.                           ;; Made it! (they're equal).
  82.                           (return t))
  83.                          (t             ;they're not equal (sob)
  84.                           (ed-beep)
  85.                           (return nil))))
  86.                   ((NOT-EQUAL-HERE? w1-buf w1-mark w2-buf w2-mark)
  87.                    ;; They're not equal (sob).
  88.                    (ed-beep)
  89.                    (return nil))
  90.                   (t                    ;check the next ones
  91.                    (move-mark w1-mark)
  92.                    (move-mark w2-mark))))
  93.       ;; get the flashy insert bar to show in new position
  94.       (set-mark (fred-display-start-mark w1) (buffer-position (fred-buffer w1)))
  95.       (fred-update w1)
  96.       (set-mark (fred-display-start-mark w2) (buffer-position (fred-buffer w2)))
  97.       (fred-update w2))))
  98.  
  99.  
  100. ;;; the menu stuff
  101.  
  102. (defclass *compare-menu-item* (menu-item)
  103.   ())
  104.  
  105.  
  106. (defmethod initialize-instance ((ich *compare-menu-item* ) &rest init-list)
  107.   (apply #'call-next-method ich
  108.          (init-list-default
  109.           init-list
  110.           :menu-item-title "Compare Top Windows"
  111.           :command-key #\h
  112.           :menu-item-action
  113.           #'(lambda ()
  114.               (compare-windows
  115.                :w1 (first (windows)) :w2 (second (windows))
  116.                :skip-white? (find-menu-item *edit-menu*
  117.                                             "Compare Top Windows (Skip)"))))))
  118.  
  119. (defmethod menu-item-update ((ich *compare-menu-item*))
  120.   "Disables the item if the top two windows aren't *fred-window*s and
  121. changes the title (if the option key is down) to 'Compare Top Windows (Skip)'"
  122.   ;;
  123.   (if (and (typep (first (windows)) 'fred-window)
  124.            (typep (second (windows)) 'fred-window))
  125.     (menu-item-enable ich)
  126.     (menu-item-disable ich))
  127.   ;;
  128.   (if (option-key-p)
  129.     (set-menu-item-title ich "Compare Top Windows (Skip)")
  130.     (set-menu-item-title ich "Compare Top Windows")))
  131.  
  132.  
  133. ;;;
  134. ;;; Add the menu item.
  135. ;;;
  136.  
  137. (progn
  138.   (dolist (menu-item (menu-items *edit-menu*))
  139.     (when (typep menu-item '*compare-menu-item*)
  140.       (remove-menu-items *edit-menu* menu-item)))
  141.   (add-menu-items *edit-menu* (make-instance '*compare-menu-item*)))
  142.  
  143.  
  144.  
  145. (provide :compare-windows)
  146.  
  147. ;;; The End.